perm filename CB.F4[DRW,LCS]3 blob sn#396827 filedate 1978-11-17 generic text, type T, neo UTF8
	SUBROUTINE CMBN
	COMMON /RC/MCLEF(400),IST(4000)
	COMMON /FL/NX,N,L,M,NM,J,NT
	DIMENSION IP(10),NMS(10),NF(2500),JP(10),NMX(10)
	EQUIVALENCE (IP,IST(3001)),(NMS,IST(3020)),(NF,IST(201))
	1,(JP,IST(1500)),(NMX,IST(1510))
C *****   ******   ****   ******              ↑ 20 FOR OVERRUN IN IP(11) AT 119
C  USE FILE NAMES CLFX, DRAW1 AND DRAW2.  400 WD LIMIT PER FILE.
	IF(N.EQ.'S')GO TO 103
102	TYPE 1
1	FORMAT(' TYPE OUTPUT FILE NAME ',$)
10	FORMAT(A5)
	DO 122 K=1,10
	IP(K)=0
122	NMS(K)=' '
	ACCEPT 10,NM
	IF(NM.NE.' ')GO TO 40
	NM=LASTNM
	TYPE 107,LASTNM
40	LASTNM=NM
	IF(LOOKF(NM).EQ.0)GO TO 100
	IF(N.NE.'C')GO TO 103
C  FOR ADDING TO COMBINED FILE.
	TYPE 101,NM
	ACCEPT 10,NX
	IF(NX.EQ.'N')GO TO 102
100	IF(N.EQ.'C')GO TO 104
	TYPE 52
	GO TO 102
104	L=0
	NX=1
	I=0
30	L=L+1
	TYPE 41
41	FORMAT(' TYPE FILE NAME ',$)
	ACCEPT 10,NW
	IF(NW.EQ.' ')GO TO 8
	IF(LOOKF(NW))GO TO 51
	TYPE 52
	GO TO 30
52	FORMAT(' FILE NOT FOUND'/)
51	I=I+1
	IP(L)=NX
	NMS(I)=NW
	CALL RDSAV(JP,NMX,K,NW,MCLEF(NX),-2)
	NX=NX+K
	IF(L.LT.10)GO TO 30
101	FORMAT(' WRITE OVER ',A5,'.DMD?  Y OR N?  ',$)
8	NX=NX-1
14	CALL RDSAV(IP,NMS,NX,NM,MCLEF,0)
	L=NX
	RETURN

1103	TYPE 1104,ID
1104	FORMAT(' FILE FULL -- SAVED AS ',A5)
	L=1
	NM=ID
	NX=MCLEF(1)
	GO TO 8

103	CALL RDSAV(IP,NMS,NX,NM,NF,-1)
107	FORMAT(1X,A5)
	TYPE 109
109	FORMAT(' TYPE ID NAME (<CR>=BACKUP) -- ',$)
	ACCEPT 10,ID
	IF(ID.EQ.' ')GO TO 102
	JD=0
	L=0
CC	NX=NX-1
	DO 110 K=1,10
	IF(NMS(K).EQ.ID)JD=K
	IF(NMS(K).EQ.' ')GO TO 112
	L=K
110	IF(JD.EQ.0.AND.K.EQ.10)GO TO 1103
112	IF(N.EQ.'Z')GO TO 127
C  FOR DELETIONS
	L=L+1
	IF(JD.NE.0)GO TO 111
C ADDS ON TO END
	N=0
	IP(L)=NX+1
	DO 113 K=NX+1,MCLEF(1)+NX
	N=N+1
113	NF(K)=MCLEF(N)
	NX=NX+N
	NMS(L)=ID
	L=L+1
114	DO 115 K=1,NX
115	MCLEF(K)=NF(K)
C MOVES IT ALL TO MCLEF
	GO TO 14

127	MCLEF(1)=0
111	N=IP(JD)
	NR=MCLEF(1)
	M=NF(IP(JD))
	NW=NR-M
	NX=NX+NW
	IF(NW)201,120,203
201	JA=N+NR
	JB=NX
	JC=1
	GO TO 204
203	JA=NX
	JB=N+NW
	JC=-1
204	DO 121 K=JA,JB,JC
121	NF(K)=NF(K-NW)
	IF(NR.EQ.0)GO TO 126
120	DO 117 K=1,NR
	NF(N)=MCLEF(K)
117	N=N+1 
CC	L=L-1
	IF(NW.EQ.0)GO TO 114
	DO 119 K=JD+1,L
119	IP(K)=IP(K)+NW
C  FIXES UP FIRST LINE.
CC123	L=L-1
CC	NX=NX-1
	GO TO 114
126	IP(L+1)=0
CC	L=L-1
	DO 124 K=JD,L-1
	IP(K)=IP(K+1)+NW
124	NMS(K)=NMS(K+1)
	NMS(L)=' '
	GO TO 114
	END

	SUBROUTINE RDSAV(KT,NMS,K,NAME,IO,L)
C  POINTER LIST, NAME LIST, WDCNT, FILE NAME, DATA, RD OR WRT.
	COMMON /RC/MCLEF(400),IST(4000)/FL/IC,NH,NQ,A,B,C,D
	DIMENSION KT(1),NMS(1),IO(1),JALL(21)
	IF(L)GO TO 5
C  L=-1  FOR READER, -2=NO TYPE OF NAME LIST.
	DO 1 N=1,10
	JALL(N)=KT(N)
1	JALL(N+11)=NMS(N)
	JALL(11)=K
	CALL PUTFIL(NAME)
	CALL FASTOU(JALL,21)
	CALL FASTOU(IO,K+1)
	CALL FINFIL
	RETURN

5	CALL GETFIL(NAME)
	CALL FASTIN(JALL,21)
	K=JALL(11)
	CALL FASTIN(IO,K)
	DO 2 N=1,10
	KT(N)=JALL(N)
2	NMS(N)=JALL(N+11)
	IF(L.EQ.-2)RETURN
	TYPE 3
	TYPE 4,(NMS(N),N=1,10)
3	FORMAT(
	1'  0      1      2      3      4      5      6      7
	1      8      9')
4	FORMAT(' IDENT. NAMES:'/,10(2XA5))
	END

	SUBROUTINE CNVT
	COMMON/RC/A(4400)
	DIMENSION J(10),NM(10),M(600),JALL(21)
	EQUIVALENCE(J,JALL,A),(NX,JALL(11)),(NM,JALL(12)),(M,A(2000))
C  POINTER LIST, TOTAL WD CNT, NAME LIST.
	TYPE 1
1	FORMAT(' TYPE OLD NAME --  '$)
	ACCEPT 2,N
2	FORMAT(A5)
	TYPE 3
3	FORMAT(' NEW NAME --  '$)
	ACCEPT 2,NN
	CALL IFILE(1,N)
	NX=1
	READ(1,4)K,J
4	FORMAT(12I)
6	READ(1,4,END=5)K,K,(M(L),L=NX,NX+K-1)
	REREAD 7,L,NM
	IF(NM(1))GO TO 5
	NX=NX+K
	GO TO 6
7	FORMAT(I,10A5)

5	NX=NX-1
	CALL RDSAV(J,NM,NX,NN,M,0)
C  POINTERS, NAMES, WDCNT, FILE NAME, ARRAY, 0=WRITE
	CALL EXIT
	END